home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #067 (1990-04)(Amiga User Group Deutschland e.V.).zip / Franz PD Disk #067 (1990-04)(Amiga User Group Deutschland e.V.).adf / Source.zip / Expression.p < prev    next >
Text File  |  1990-02-06  |  23KB  |  873 lines
  1. External;
  2.  
  3. {
  4.     Expression.p (of PCQ Pascal)
  5.     Copyright (c) 1989 Patrick Quaid
  6.  
  7.     This module only has two parts.  The first is expression(),
  8. which handles all run-time expressions.  The other one is
  9. conexpr(), which handles all constant expressions.
  10. }
  11.  
  12. {$O-}
  13. {$I "Pascal.i"}
  14.  
  15.     Function TypeCheck(l, r : TypePtr) : Boolean;
  16.         external;
  17.     procedure NextSymbol;
  18.         external;
  19.     procedure Error(s : string);
  20.         external;
  21.     Procedure Abort;
  22.         external;
  23.     Procedure ReadChar;
  24.         external;
  25.     Function  EndOfFile() : Boolean;
  26.         external;
  27.     Procedure CallFunc(f : IDPtr);
  28.         external;
  29.     Procedure StdFunc(f : IDPtr);
  30.         external;
  31.     Function Match(s : Symbols): Boolean;
  32.         external;
  33.     Function FindID(s : string) : IDPtr;
  34.         external;
  35.     Function FindWithField(s : String) : IDPtr;
  36.         External;
  37.     Procedure PrintLabel(l : Integer);
  38.         external;
  39.     Function GetLabel() : Integer;
  40.         external;
  41.     Function Selector(f : IDPtr) : TypePtr;
  42.         external;
  43.     Function GetFramePointer(Ref : Integer) : Short;
  44.         External;
  45.     Procedure Mismatch;
  46.         external;
  47.     Procedure NoLeftParent;
  48.         external;
  49.     Procedure NoRightParent;
  50.         external;
  51.     Procedure NeedNumber;
  52.         external;
  53.     Procedure NeedRightParent;
  54.         external;
  55.     Procedure NeedLeftParent;
  56.         external;
  57.     Function Suffix(s : Integer) : Char;
  58.         external;
  59.     Function NumberType(l : TypePtr) : Boolean;
  60.         external;
  61.     Function BaseType(b : TypePtr): TypePtr;
  62.         external;
  63.     Function SimpleType(t : TypePtr) : Boolean;
  64.         external;
  65.     Procedure WriteHex(h : Integer);
  66.         external;
  67.     Procedure PromoteType(var f : TypePtr; o : TypePtr; r : Short);
  68.         external;
  69.     Procedure PushLongD0;
  70.         external;
  71.     Procedure PushLongD1;
  72.         External;
  73.     Procedure PopLongD1;
  74.         external;
  75.     Procedure PopLongA1;
  76.         External;
  77.     Procedure PopStackSpace(amount : Integer);
  78.         External;
  79.     Function EnterStandard(    st_Name : String;
  80.                 st_Object : IDObject;
  81.                 st_Type : TypePtr;
  82.                 st_Storage : IDStorage;
  83.                 st_Offset : Integer) : IDPtr;
  84.         external;
  85.  
  86. Function Expression() : TypePtr;
  87.     forward;
  88.  
  89. Procedure IncLitPtr;
  90. begin
  91.     if LitPtr >= LiteralSize then begin
  92.     Writeln('Too much literal data');
  93.     Abort;
  94.     end else
  95.     LitPtr := Succ(LitPtr);
  96. end;
  97.  
  98. Function ReadLit(Quote : Char) : TypePtr;
  99.  
  100. {
  101.     This routine reads a literal array of char into the literal
  102. array.
  103. }
  104. var
  105.     Length : Short;
  106. begin
  107.     Length := 1;
  108.     while (currentchar <> Quote) and (currentchar <> chr(10)) do begin
  109.     if CurrentChar = '\\' then begin
  110.         ReadChar;
  111.         if CurrentChar = Chr(10) then
  112.         Error("Missing closing quote");
  113.         case CurrentChar of
  114.           'n' : Litq[LitPtr] := Chr(10);
  115.           't' : Litq[LitPtr] := Chr(9);
  116.           '0' : Litq[LitPtr] := Chr(0);
  117.           'b' : Litq[LitPtr] := Chr(8);
  118.           'e' : Litq[LitPtr] := Chr(27);
  119.           'c' : Litq[LitPtr] := Chr($9B);
  120.           'a' : Litq[LitPtr] := Chr(7);
  121.           'f' : Litq[LitPtr] := Chr(12);
  122.           'r' : Litq[LitPtr] := Chr(13);
  123.           'v' : Litq[LitPtr] := Chr(11);
  124.         else
  125.         Litq[LitPtr] := CurrentChar;
  126.         end;
  127.     end else
  128.         Litq[LitPtr] := CurrentChar;
  129.     if CurrentChar <> Chr(10) then begin
  130.         ReadChar;
  131.         if currentchar = chr(10) then
  132.         error("Missing closing quote");
  133.     end;
  134.     Length := Succ(Length);
  135.     IncLitPtr;
  136.     end;
  137.     ReadChar;
  138.     NextSymbol;
  139.     if Quote = '"' then begin
  140.     LitQ[LitPtr] := Chr(0);
  141.     IncLitPtr;
  142.     ReadLit := StringType;
  143.     end else begin
  144.     LiteralType^.Upper := Length - 1;
  145.     ReadLit := LiteralType;
  146.     end;
  147. end;
  148.  
  149. Function LoadValue(ID : IDPtr) : TypePtr;
  150. var
  151.     TP : TypePtr;
  152.     Reg : Short;
  153. begin
  154.     TP := ID^.VType;
  155.     case ID^.Object of
  156.       typed_const,
  157.       global : if ID^.Level <= 1 then begin
  158.            if SimpleType(TP) then
  159.             writeln(OutFile,"\tmove.", Suffix(TP^.Size),
  160.                     "\t_", ID^.Name, ',d0')
  161.            else
  162.             Writeln(OutFile, "\tmove.l\t#_", ID^.Name, ',d0');
  163.         end else begin
  164.            if SimpleType(TP) then
  165.             writeln(OutFile, '\tmove.', Suffix(TP^.Size), '\t_',
  166.                     ID^.Name, '%', ID^.Unique, ',d0')
  167.            else
  168.             writeln(OutFile, '\tmove.l\t#_', ID^.Name, '%',
  169.                     ID^.Unique, ',d0');
  170.         end;
  171.       local,
  172.       valarg : begin
  173.            Reg := GetFramePointer(ID^.Level);
  174.            if SimpleType(TP) then
  175.             Writeln(OutFile, "\tmove.", Suffix(TP^.Size),
  176.                     Chr(9), ID^.Offset, '(a', Reg, '),d0')
  177.            else begin
  178.             Writeln(OutFile, "\tlea\t", ID^.Offset, '(a', Reg, '),a0');
  179.             Writeln(OutFile, "\tmove.l\ta0,d0");
  180.            end;
  181.            end;
  182.       refarg : begin
  183.            Reg := GetFramePointer(ID^.Level);
  184.            if SimpleType(TP) then begin
  185.             Writeln(OutFile, "\tmove.l\t", ID^.Offset, '(a', Reg, '),a0');
  186.             Writeln(OutFile, "\tmove.", Suffix(TP^.Size), "\t(a0),d0");
  187.            end else
  188.             writeln(OutFile, "\tmove.l\t", ID^.Offset, '(a', Reg, '),d0')
  189.            end;
  190.     else begin
  191.         Error("expecting a variable or function");
  192.         TP := BadType;
  193.      end;
  194.     end;
  195.     LoadValue := TP;
  196. end;
  197.  
  198. Procedure ReadBadArgs;
  199. var
  200.     TP : TypePtr;
  201. begin
  202.     if Match(LeftParent1) then begin
  203.     While (CurrSym <> RightParent1) and (CurrSym <> SemiColon1) and
  204.         (Not EndOfFile()) do begin
  205.         TP := Expression();
  206.         if CurrSym <> RightParent1 then
  207.         if not Match(Comma1) then
  208.             Error("Expecting a comma");
  209.     end;
  210.     NeedRightParent;
  211.     end;
  212. end;
  213.  
  214. Function IDFactor(ID : IDPtr) : TypePtr;
  215.  
  216. {
  217.     idfactor() is another nightmare function.  It does whatever
  218. is necessary when the compiler runs across an identifer in an
  219. expression, which almost always means loading a value into d0.
  220. }
  221.  
  222. var
  223.     TP : TypePtr;
  224. begin
  225.     if ID = nil then begin
  226.     Error("Unknown ID");
  227.     ID := EnterStandard(SymText, global, BadType, st_none, 1);
  228.     NextSymbol;
  229.     ReadBadArgs;
  230.     IDFactor := BadType;
  231.     end else begin
  232.     case ID^.Object of
  233.       func : begin
  234.             CallFunc(ID);
  235.             IDFactor := ID^.VType;
  236.          end;
  237.       stanfunc : begin
  238.             StdFunc(ID);
  239.             IDFactor := ID^.VType;
  240.          end;
  241.       obtype : begin
  242.             NeedLeftParent;
  243.             TP := Expression();
  244.             NeedRightParent;
  245.             IDFactor := ID^.VType;
  246.          end;
  247.       constant : begin
  248.             TP := ID^.VType;
  249.             if TP^.Object = ob_ordinal then { Integer, Short, etc. }
  250.                 writeln(OutFile, "\tmove.l\t#",
  251.                     ID^.Offset, ',d0')
  252.             else if TP^.Object = ob_pointer then begin
  253.              { String or Nil }
  254.                 if TP = StringType then begin
  255.                 write(OutFile, "\tmove.l\t#");
  256.                 PrintLabel(litlab);
  257.                 writeln(OutFile, '+', ID^.Offset, ',d0');
  258.                 end else
  259.                 writeln(OutFile, "\tmove.l\t#", ID^.Offset, ',d0');
  260.             end else if TP^.Object = ob_array then begin
  261.               { Must be charray }
  262.                 write(OutFile, "\tmove.l\t#");
  263.                 PrintLabel(litlab);
  264.                 writeln(OutFile, '+', ID^.Offset, ',d0');
  265.             end else if TP^.Object = ob_real then begin
  266.                 Write(Outfile, "\tmove.l\t#");
  267.                 writehex(ID^.Offset);
  268.                 writeln(OutFile, ',d0');
  269.             end;
  270.             IDFactor := TP;
  271.             end;
  272.     else begin { Else clause of CASE, remember }
  273.         TP := Selector(ID);
  274.         if TP <> Nil then begin
  275.             if SimpleType(TP) then
  276.             writeln(OutFile, "\tmove.",
  277.                 Suffix(TP^.Size), "\t(a0),d0")
  278.             else
  279.             writeln(OutFile, "\tmove.l\ta0,d0");
  280.         end else
  281.             TP := LoadValue(ID);
  282.         IDFactor := TP;
  283.          end;
  284.     end;
  285.     end;
  286. end;
  287.  
  288. Function Factor() : TypePtr;
  289.  
  290. {
  291.     This is the lowest level of the expression parsing
  292. business.  It's pretty standard stuff.  All these expression
  293. routines return a pointer to the type they're working on.
  294. }
  295. var
  296.     ID : IDPtr;
  297.     TP, TP2 : TypePtr;
  298.     LitSpot : Integer;
  299. begin
  300.     if CurrSym = Ident1 then begin
  301.     ID := FindWithField(SymText);
  302.     if ID = Nil then
  303.         ID := FindID(SymText);
  304.     nextsymbol;
  305.     Factor := IDFactor(ID);
  306.     end else if CurrSym = Numeral1 then begin
  307.     Write(OutFile, "\tmove.l\t#");
  308.     if abs(symloc) > 1000000 then begin
  309.         writehex(symloc);
  310.         writeln(OutFile, ',d0');
  311.     end else
  312.         writeln(OutFile, symloc, ',d0');
  313.     nextsymbol;
  314.     Factor := IntType;
  315.    end else if CurrSym = RealNumeral1 then begin
  316.     write(OutFile, "\tmove.l\t#");
  317.     writehex(integer(RealValue));
  318.     writeln(OutFile, ',d0');
  319.     nextsymbol;
  320.     Factor := RealType;
  321.     end else if Currsym = Apostrophe1 then begin
  322.     LitSpot := LitPtr;
  323.     TP := ReadLit(Chr(39));
  324.     if TP^.Upper = 1 then begin
  325.         LitPtr := Pred(LitPtr);
  326.         Writeln(OutFile, "\tmove.b\t#", Ord(LitQ[LitPtr]), ',d0');
  327.         Factor := CharType;
  328.     end else begin
  329.         New(TP2);
  330.         TP2^ := TP^;
  331.         TP2^.Next := CurrentBlock^.FirstType;
  332.         CurrentBlock^.FirstType := TP2;
  333.         Write(OutFile, "\tmove.l\t#");
  334.         PrintLabel(LitLab);
  335.         Writeln(OutFile, '+', LitSpot, ',d0');
  336.         Factor := TP2;
  337.     end;
  338.     end else if CurrSym = Quote1 then begin
  339.     Write(OutFile, "\tmove.l\t#");
  340.     PrintLabel(LitLab);
  341.     Writeln(OutFile, '+', LitPtr, ',d0');
  342.     Factor := ReadLit('"');
  343.     end else if match(not1) then begin
  344.     TP := Factor();
  345.     if TP^.Object <> ob_ordinal then begin
  346.         error("NOT applies only to ordinal values");
  347.         Factor := BadType;
  348.     end else
  349.         writeln(OutFile, "\tnot.", Suffix(TP^.Size), "\td0");
  350.     Factor := TP;
  351.     end else if Match(LeftParent1) then begin
  352.     TP := Expression();
  353.     NeedRightParent;
  354.     Factor := TP;
  355.     end else begin
  356.     error("Unrecognizable expression");
  357.     NextSymbol;
  358.     Factor := BadType;
  359.     end;
  360. end;
  361.     
  362. Function Operate(LeftType, RightType : TypePtr; Operator : Symbols) : TypePtr;
  363.  
  364. {
  365.     This routine handles the actual code generation for the
  366. various operations.  This handles all the math stuff, even though
  367. it's called by different routines.
  368. }
  369.  
  370. var
  371.     Suffer : Char;
  372. begin
  373.     if not TypeCheck(LeftType, RightType) then begin
  374.     Mismatch;
  375.     Operate := BadType;
  376.     end else begin
  377.     PopLongD1;
  378.     if (Operator = And1) or (Operator = Or1) or (Operator = Xor1) or
  379.        (Operator = Shl1) or (Operator = Shr1) then begin
  380.         if LeftType^.Object <> ob_ordinal then
  381.         Error("Need ordinal expression")
  382.         else if LeftType^.size <> RightType^.Size then begin
  383.         PromoteType(lefttype, RightType, 1);
  384.         PromoteType(RightType, lefttype, 0);
  385.         end;
  386.     end else begin
  387.         if NumberType(LeftType) or (LeftType = RealType) then begin
  388.         PromoteType(LeftType, RightType, 1);
  389.         PromoteType(RightType, LeftType, 0);
  390.         end else
  391.         NeedNumber;
  392.     end;
  393.     Suffer := Suffix(LeftType^.Size);
  394.     if Operator = Asterisk1 then begin
  395.         if LeftType = ByteType then begin
  396.         PromoteType(LeftType, ShortType, 1);
  397.         PromoteType(RightType, ShortType, 0);
  398.         end;
  399.         if LeftType = ShortType then begin
  400.         writeln(OutFile, "\tmuls\td1,d0");
  401.         Operate := IntType;
  402.         end else if LeftType = IntType then begin
  403.         PushLongD0;
  404.         PushLongD1;
  405.         writeln(OutFile, "\tjsr\t_p%lmul");
  406.         PopStackSpace(8);
  407.         Operate := Inttype;
  408.         end else begin
  409.         writeln(OutFile, "\tmove.l\t_p%MathBase,a6");
  410.         writeln(OutFile, "\tjsr\t-78(a6)");
  411.         Operate := RealType;
  412.         end;
  413.     end else if Operator = Div1 then begin
  414.         if LeftType <> IntType then
  415.         PromoteType(LeftType, IntType, 1);
  416.         if RightType = ByteType then
  417.         PromoteType(RightType, ShortType, 0);
  418.         if RightType = ShortType then begin
  419.         writeln(OutFile, "\tdivs\td0,d1");
  420.         writeln(OutFile, "\tmove.l\td1,d0");
  421.         Operate := ShortType;
  422.         end else if RightType = IntType then begin
  423.         PushLongD0;
  424.         PushLongD1;
  425.         writeln(OutFile, "\tjsr\t_p%ldiv");
  426.         PopStackSpace(8);
  427.         Operate := IntType;
  428.         end else begin
  429.         Error("No reals allowed for DIV");
  430.         Operate := BadType;
  431.         end;
  432.     end else if Operator = Mod1 then begin
  433.         if LeftType <> IntType then
  434.         PromoteType(LeftType, IntType, 1);
  435.         if RightType = ByteType then
  436.         PromoteType(RightType, ShortType, 0);
  437.         if RightType = ShortType then begin
  438.         writeln(OutFile, "\tdivs\td0,d1");
  439.         writeln(OutFile, "\tmove.l\td1,d0");
  440.         writeln(OutFile, "\tswap\td0");
  441.         Operate := ShortType;
  442.         end else if RightType = IntType then begin
  443.         PushLongD0;
  444.         PushLongD1;
  445.         writeln(OutFile, "\tjsr\t_p%lrem");
  446.         PopStackSpace(8);
  447.         Operate := IntType;
  448.         end else begin
  449.         Error("No reals allowed for MOD");
  450.         Operate := BadType;
  451.         end;
  452.     end else if Operator = And1 then begin
  453.         writeln(OutFile, "\tand.", suffer, "\td1,d0");
  454.         Operate := LeftType;
  455.     end else if Operator = Shl1 then begin
  456.         writeln(OutFile, "\tand.w\t#31,d0");
  457.         if LeftType^.Size = 1 then
  458.         Writeln(OutFile, '\tand.l\t#$FF,d1')
  459.         else if LeftType^.Size = 2 then
  460.         Writeln(OutFile, '\tand.l\t#$FFFF,d1');
  461.         writeln(OutFile, "\tasl.", Suffer, "\td0,d1");
  462.         writeln(OutFile, "\tmove.", Suffer, "\td1,d0");
  463.         Operate := LeftType;
  464.     end else if Operator = Shr1 then begin
  465.         writeln(OutFile, "\tand.w\t#31,d0");
  466.         if LeftType^.Size = 1 then
  467.         Writeln(OutFile, '\tand.l\t#$FF,d1')
  468.         else if LeftType^.Size = 2 then
  469.         Writeln(OutFile, '\tand.l\t#$FFFF,d1');
  470.         writeln(OutFile, "\tlsr.", Suffer, "\td0,d1");
  471.         writeln(OutFile, "\tmove.", Suffer, "\td1,d0");
  472.         Operate := LeftType;
  473.     end else if Operator = Plus1 then begin
  474.         if LeftType = RealType then begin
  475.         writeln(OutFile, "\tmove.l\t_p%MathBase,a6");
  476.         writeln(OutFile, "\tjsr\t-66(a6)");
  477.         end else
  478.         writeln(OutFile, "\tadd.", Suffer, "\td1,d0");
  479.         Operate := LeftType;
  480.     end else if Operator = Minus1 then begin
  481.         writeln(OutFile, "\texg\td0,d1");
  482.         if LeftType = RealType then begin
  483.         writeln(OutFile, "\tmove.l\t_p%MathBase,a6");
  484.         writeln(OutFile, "\tjsr\t-72(a6)");
  485.         end else
  486.         writeln(OutFile, "\tsub.", Suffer, "\td1,d0");
  487.         Operate := LeftType;
  488.     end else if Operator = RealDiv1 then begin
  489.         PromoteType(LeftType, RealType, 1);
  490.         PromoteType(RightType, RealType, 0);
  491.         writeln(OutFile, "\texg\td0,d1");
  492.         writeln(OutFile, "\tmove.l\t_p%MathBase,a6");
  493.         writeln(OutFile, "\tjsr\t-84(a6)");
  494.         Operate := RealType;
  495.     end else if Operator = Or1 then begin
  496.         writeln(OutFile, "\tor.", suffer, "\td1,d0");
  497.         Operate := LeftType;
  498.     end else if Operator = Xor1 then begin
  499.         writeln(OutFile, "\teor.", Suffer, "\td1,d0");
  500.         Operate := LeftType;
  501.     end;
  502.     end;
  503. end;
  504.  
  505. Function Term() : TypePtr;
  506.  
  507. {
  508.     Again, pretty standard stuff.  This handles the level of
  509. precedence that includes *, div, mod, /, and, and unary minus.
  510. }
  511.  
  512. var
  513.     LeftType  : TypePtr;
  514.     stay : Boolean;
  515. begin
  516.     if Match(Minus1) then begin
  517.     LeftType := Factor();
  518.     if LeftType = RealType then begin
  519.         writeln(OutFile, "\tmove.l\t_p%MathBase,a6");
  520.         writeln(OutFile, "\tjsr\t-60(a6)");
  521.     end else if TypeCheck(LeftType, IntType) then
  522.         writeln(OutFile, "\tneg.", suffix(LeftType^.Size),"\td0")
  523.     else begin
  524.         Error("Need numeric type for unary minus");
  525.         LeftType := BadType;
  526.     end;
  527.     end else
  528.     LeftType := Factor();
  529.     stay := true;
  530.     while stay do begin
  531.     if Match(Asterisk1) then begin
  532.         PushLongD0;
  533.         LeftType := Operate(LeftType, Factor(), asterisk1);
  534.     end else if Match(Div1) then begin
  535.         PushLongD0;
  536.         LeftType := Operate(LeftType, Factor(), div1);
  537.     end else if match(realdiv1) then begin
  538.         PushLongD0;
  539.         LeftType := Operate(LeftType, Factor(), realdiv1);
  540.     end else if match(mod1) then begin
  541.         PushLongD0;
  542.         LeftType := Operate(LeftType, Factor(), mod1);
  543.     end else if match(and1) then begin
  544.         PushLongD0;
  545.         LeftType := Operate(LeftType, Factor(), and1);
  546.     end else if Match(Shl1) then begin
  547.         PushLongD0;
  548.         LeftType := Operate(LeftType, Factor(), Shl1);
  549.     end else if Match(Shr1) then begin
  550.         PushLongD0;
  551.         LeftType := Operate(LeftType, Factor(), Shr1);
  552.     end else
  553.         stay := false;
  554.     end;
  555.     Term := LeftType;
  556. end;
  557.  
  558. Function Simple() : TypePtr;
  559.  
  560. {
  561.     This is similar to term(), except it handles plus, minus,
  562. and or.
  563. }
  564.  
  565. var
  566.     LeftType    : TypePtr;
  567.     Stay    : Boolean;
  568. begin
  569.     LeftType := Term();
  570.     Stay := True;
  571.     while Stay do begin
  572.     if Match(Plus1) then begin
  573.         PushLongD0;
  574.         LeftType := Operate(LeftType, Term(), plus1);
  575.     end else if match(minus1) then begin
  576.         PushLongD0;
  577.         LeftType := Operate(LeftType, Term(), minus1);
  578.     end else if match(or1) then begin
  579.         PushLongD0;
  580.         LeftType := Operate(LeftType, Term(), or1);
  581.     end else if Match(Xor1) then begin
  582.         PushLongD0;
  583.         LeftType := Operate(LeftType, Term(), Xor1);
  584.     end else
  585.         Stay := false;
  586.     end;
  587.     Simple := LeftType;
  588. end;
  589.  
  590. Function ExprRelOp(LeftType : TypePtr; Operation : Symbols) : TypePtr;
  591.  
  592. {
  593.     This handles the code for the various relative comparisons
  594. (like <, >, <=, etc.)
  595. }
  596.  
  597. var
  598.     RightType    : TypePtr;
  599. begin
  600.     NextSymbol;
  601.     PushLongD0;
  602.     RightType := Simple();
  603.     if not TypeCheck(LeftType, RightType) then begin
  604.     Mismatch;
  605.     ExprRelOp := BadType;
  606.     end else if not SimpleType(LeftType) then begin
  607.     error("only simple types allowed in inequalities");
  608.     ExprRelOp := BadType;
  609.     end else begin
  610.     PopLongD1;
  611.     if NumberType(LeftType) or (LeftType = RealType) then begin
  612.         PromoteType(LeftType, RightType, 1);
  613.         PromoteType(RightType, LeftType, 0);
  614.     end;
  615.     if LeftType = RealType then begin
  616.         writeln(OutFile, "\texg\td0,d1");
  617.         writeln(OutFile, "\tmove.l\t_p%MathBase,a6");
  618.         writeln(OutFile, "\tjsr\t-42(a6)");
  619.     end else
  620.         writeln(OutFile, "\tcmp.", Suffix(LeftType^.Size), "\td0,d1");
  621.     if Operation = Less1 then
  622.         writeln(OutFile, "\tslt\td0")
  623.     else if Operation = greater1 then
  624.         writeln(OutFile, "\tsgt\td0")
  625.     else if Operation = notless1 then
  626.         writeln(OutFile, "\tsge\td0")
  627.     else if Operation = notgreater1 then
  628.         writeln(OutFile, "\tsle\td0");
  629.     ExprRelOp := BoolType;
  630.     end;
  631. end;
  632.  
  633. Function ExprEqOp(LeftType : TypePtr; Operation : Symbols) : TypePtr;
  634.  
  635. {
  636.     This generates code for comparisons of equality.  The main
  637. difference between this and the previous routine is that Pascal
  638. allows the comparison of complex types, so this routine has to
  639. handle that.
  640. }
  641.  
  642. var
  643.     RightType    : TypePtr;
  644.     lab        : Integer;
  645.     TotalSize    : Integer;
  646. begin
  647.     NextSymbol;
  648.     PushLongD0;
  649.     RightType := Simple();
  650.     if not TypeCheck(LeftType, RightType) then begin
  651.     Mismatch;
  652.     ExprEqOp := BadType;
  653.     end else begin
  654.     TotalSize := LeftType^.Size;
  655.     if not SimpleType(LeftType) then begin
  656.         writeln(OutFile, "\tmove.l\td0,a0");
  657.         PopLongA1;
  658.         writeln(OutFile, "\tmove.b\t#-1,d0");
  659.         writeln(OutFile, "\tmove.l\t#", totalsize - 1, ",d1");
  660.         lab := GetLabel();
  661.         PrintLabel(lab);
  662.         writeln(OutFile, "\tmove.b\t(a0)+,d2");
  663.         writeln(OutFile, "\tcmp.b\t(a1)+,d2");
  664.         writeln(OutFile, "\tseq\td2");
  665.         writeln(OutFile, "\tand.b\td2,d0");
  666.         write(OutFile, "\tdbra\td1,");
  667.         PrintLabel(lab);
  668.         writeln(OutFile);
  669.         writeln(OutFile, "\ttst.b\td0");
  670.         if Operation = notequal1 then
  671.         writeln(OutFile, "\tseq\td0");
  672.     end else begin
  673.         PopLongD1;
  674.         if NumberType(LeftType) or (LeftType = RealType) then begin
  675.         promotetype(LeftType, RightType, 1);
  676.         promotetype(RightType, LeftType, 0);
  677.         end;
  678.         if LeftType = RealType then begin
  679.         writeln(OutFile, "\tmove.l\t_p%MathBase,a6");
  680.         writeln(OutFile, "\tjsr\t-42(a6)");
  681.         end else
  682.         writeln(OutFile, "\tcmp.", Suffix(LeftType^.Size), "\td0,d1");
  683.         if Operation = equal1 then
  684.         writeln(OutFile, "\tseq\td0")
  685.         else
  686.         writeln(OutFile, "\tsne\td0");
  687.     end;
  688.     ExprEqOp := BoolType;
  689.     end;
  690. end;
  691.  
  692. Function Expression() : TypePtr;
  693.  
  694. {
  695.     This is the main part of expression().  If there weren't
  696. any errors, the result of the expression will be in d0.
  697. }
  698.  
  699. var
  700.     LeftType : TypePtr;
  701.     stay : Boolean;
  702. begin
  703.     LeftType := Simple();
  704.     stay := True;
  705.     while stay do begin
  706.     case CurrSym of
  707.       equal1,
  708.       notequal1 : LeftType := ExprEqOp(LeftType, CurrSym);
  709.       less1,
  710.       greater1,
  711.       notless1,
  712.       notgreater1 : LeftType := ExprRelOp(LeftType, CurrSym);
  713.     else
  714.       stay := False;
  715.     end;
  716.     end;
  717.     Expression := LeftType;
  718. end;
  719.  
  720. Function ConExpr(VAR ConType : TypePtr) : Integer;
  721.     forward;
  722.  
  723. Function ConPrimary(VAR ConType : TypePtr) : Integer;
  724.  
  725. {
  726.     These routines are very similar to the other expression
  727. routines, but are much simpler.  They return the running value of
  728. the expression.  The type is returned in the reference parameter.
  729. This routine should handle type conversions and standard functions.
  730. }
  731.  
  732. var
  733.     Result    : Integer;
  734.     ID        : IDPtr;
  735.     TP        : TypePtr;
  736. begin
  737.     if Match(LeftParent1) then begin
  738.     Result := ConExpr(contype);
  739.     NeedRightParent;
  740.     ConPrimary := Result;
  741.     end else if CurrSym = Numeral1 then begin
  742.     Result := Symloc;
  743.     NextSymbol;
  744.     ConType := IntType;
  745.     ConPrimary := Result;
  746.     end else if CurrSym = RealNumeral1 then begin
  747.     Result := Integer(RealValue);
  748.     NextSymbol;
  749.     ConType := RealType;
  750.     ConPrimary := Result;
  751.     end else if Match(Minus1) then begin
  752.     ConPrimary := -ConPrimary(ConType);
  753.     end else if Currsym = Apostrophe1 then begin
  754.     Result := LitPtr;
  755.     ConType := ReadLit(Chr(39));
  756.     if ConType^.Upper = 1 then begin
  757.         LitPtr := Pred(LitPtr);
  758.         Result := Ord(LitQ[LitPtr]);
  759.         ConType := CharType;
  760.     end else begin
  761.         New(TP);
  762.         TP^ := ConType^;
  763.         TP^.Next := CurrentBlock^.FirstType;
  764.         CurrentBlock^.FirstType := TP;
  765.         ConType := TP;
  766.     end;
  767.     ConPrimary := Result;
  768.     end else if CurrSym = Quote1 then begin
  769.     Result := LitPtr;
  770.     ConType := ReadLit('"');
  771.     ConPrimary := Result;
  772.     end else if CurrSym = Ident1 then begin
  773.     ID := FindID(symtext);
  774.     if ID <> Nil then begin
  775.         if (ID^.Object = constant) or (ID^.Object = typed_const) then begin
  776.         NextSymbol;
  777.         ConType := ID^.VType;
  778.         ConPrimary := ID^.Offset;
  779.         end;
  780.     end;
  781.     error("Expecting a constant");
  782.     ConType := IntType;
  783.     ConPrimary := 1;
  784.     end else begin
  785.     error("Unknown Constant");
  786.     ConType := IntType;
  787.     ConPrimary := 1;
  788.     end;
  789. end;
  790.  
  791. Function ConFactor(VAR ConType : TypePtr) : Integer;
  792.  
  793. {
  794.     This handles the second level of precedence for constant
  795. expressions.
  796. }
  797.  
  798. var
  799.     Result, Rightresult    : integer;
  800.     RightType    : TypePtr;
  801. begin
  802.     Result := ConPrimary(ConType);
  803.     While (CurrSym = Asterisk1) or (CurrSym = Div1) or
  804.       (CurrSym = RealDiv1) do begin
  805.     if (not NumberType(ConType)) and (ConType <> RealType) then
  806.         NeedNumber;
  807.     if Match(Asterisk1) then begin
  808.         RightResult := ConPrimary(RightType);
  809.         if TypeCheck(ConType, RightType) then begin
  810.         if ConType = Realtype then
  811.             Result := Integer(Real(result) * Real(RightResult))
  812.         else
  813.             Result := Result * RightResult
  814.         end else
  815.         Mismatch;
  816.     end else if (CurrSym = Div1) or (CurrSym = RealDiv1) then begin
  817.         NextSymbol;
  818.         Rightresult := ConPrimary(RightType);
  819.         if TypeCheck(ConType, RightType) then begin
  820.         if RightResult = 0 then begin
  821.             error("Division by zero");
  822.             RightResult := 1;
  823.         end;
  824.         if ConType = Realtype then
  825.             Result := Integer(real(Result) / Real(RightResult))
  826.         else
  827.             Result := Result div RightResult;
  828.         end else
  829.         Mismatch;
  830.     end;
  831.     end;
  832.     ConFactor := Result;
  833. end;
  834.  
  835. Function ConExpr(VAR ConType : TypePtr) : Integer;
  836.  
  837. {
  838.     This handles the other level of constant expressions, and
  839. is also the outermost level.
  840. }
  841.  
  842. var
  843.     Result,
  844.     RightResult    : Integer;
  845.     Righttype    : TypePtr;
  846. begin
  847.     Result := ConFactor(ConType);
  848.     while (CurrSym = Minus1) or (CurrSym = Plus1) do begin
  849.     if (not NumberType(ConType)) and (ConType <> RealType) then
  850.         NeedNumber;
  851.     if Match(Minus1) then begin
  852.         RightResult := ConFactor(RightType);
  853.         if TypeCheck(ConType, RightType) then begin
  854.         if ConType = RealType then
  855.             Result := Integer(Real(Result) - Real(RightResult))
  856.         else
  857.             Result := Result - Rightresult;
  858.         end else
  859.         Mismatch;
  860.     end else if Match(Plus1) then begin
  861.         RightResult := ConFactor(RightType);
  862.         if TypeCheck(ConType, RightType) then begin
  863.         if ConType = RealType then
  864.             Result := Integer(Real(Result) + Real(RightResult))
  865.         else
  866.             Result := Result + Rightresult;
  867.         end else
  868.         Mismatch;
  869.     end;
  870.     end;
  871.     ConExpr := Result;
  872. end;
  873.